perm filename DELETE.SAI[PNT,HE]1 blob sn#327517 filedate 1978-01-06 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00011 ENDMK
C⊗;
ENTRY;
BEGIN
REQUIRE "MACROS.SAI[PNT,HE]" SOURCE_FILE;
REQUIRE "RECORD.DEF[PNT,HE]" SOURCE_FILE;

EXTERNAL STRING TOKEN;
EXTERNAL INTEGER $HELP,$LAST;
EXTERNAL PROCEDURE GTOKEN(BOOLEAN REPEAT);
EXTERNAL STRING $TRLST,$FRLST,$SCLST,$VTLST,$RTLST,$OULST,$DFLST; 
EXTERNAL INTEGER $ALLOW;				! when >0 no display updating;
EXTERNAL PROCEDURE ABORT1(STRING S1,S2(NULL));
EXTERNAL SIMPLE  BOOLEAN PROCEDURE FINAL;
EXTERNAL PROCEDURE ESC_P;
EXTERNAL PROCEDURE KILLVAR(STRING XX);
EXTERNAL SIMPLE  STRING PROCEDURE IDF_READ;
EXTERNAL STRING ARRAY $SYNMSG[0:34];
EXTERNAL STRING ARRAY $SEMSG[0:13];
EXTERNAL BOOLEAN STOKEN;
EXTERNAL PROCEDURE ERROR(STRING ERR1,ERR2(NULL));
EXTERNAL PROCEDURE UPDATE;
EXTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL);
EXTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PROCEDURE MK_REC(INTEGER TYPE);
EXTERNAL PROCEDURE UNLINK(RPTR(FRAME) N);
EXTERNAL RPTR(TRANS) PROCEDURE DOTREXP(REAL W,PH,TH,X,Y,Z);
EXTERNAL PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);

PROCEDURE RESET;
	BEGIN
	INTEGER IND,I,TEMP;INTEGER ARRAY SAVE[#MIN:#MAX];RPTR(FRAME)WHAT;
	IFC #KILL THENC $LAST←0;ENDC 		! unkillable instruction;
	SAVE[#SC]←2;			! 2 scalars predefined in the system;
	SAVE[#VT]←4;			! 4 vectors;
	SAVE[#RT]←1;			! 1 rotation;
 	SAVE[#FR]←5;			! 5 frames;
	SAVE[#TR]←1;			! 1 trans;
	FOR IND←#MIN STEP 1 UNTIL #MAX DO
	    BEGIN			
	    ! deletes the records defined for each type saving the predefined ones;
	    TEMP←$ENTRY[IND]-1;
	    FOR I←#LTYPE*(IND-#MIN)+SAVE[IND] STEP 1 UNTIL TEMP DO
		$YMTAB[I]←NULL_RECORD;	
	    $ENTRY[IND]←#LTYPE*(IND-#MIN)+SAVE[IND];	! remembers the new $ENTRY to $YMTAB;
	    END;

					! updates the frame tree structure;
	$ALLOW←$ALLOW+1;
				! kills the sons of WORLD,unless the predefined ones;
	WHAT←FRAME:SON[F_WRLD];
 	WHILE WHAT AND WHAT≠F_BARM AND WHAT≠F_YARM AND WHAT≠F_BPARK AND WHAT≠F_YPARK
	     DO BEGIN
		UNLINK(WHAT);
		WHAT←FRAME:SON[F_WRLD];
		END;

		! kills the sons of BARM and YARM;
	FRAME:SON[F_BARM]←FRAME:SON[F_YARM]←NULL_RECORD;
	F_FID←F_POINTER←F_BGRASP←NULL_RECORD;

	! clears BARM to define again BGRASP and POINTER, then read_barm;
	ARRTRAN(FRAME:XF[F_BARM],TRANS:XF[T_NILTRANS]);

		! defines again BGRASP;
 	FRAME:PNAME[SYMBOL:OBJECT[BGRASP←ENSYM("BGRASP",#FR,F_BGRASP←MK_REC(#FR))]]
						←"BGRASP";
	ARRTRAN(FRAME:XF[F_BGRASP],TRANS:XF[DOTREXP(-180,180,0,0,0,0)]);
	AFX_NODE(F_BGRASP,F_BARM,#RGDLK);

		! defines again POINTER;
 	FRAME:PNAME[SYMBOL:OBJECT[POINTER←ENSYM("POINTER",#FR,F_POINTER←MK_REC(#FR))]]
						←"POINTER";
	ARRTRAN(FRAME:XF[F_POINTER],
		TRANS:XF[DOTREXP(-.417,13.2,-5.173,.0121,.119,3.75)]);
	AFX_NODE(F_POINTER,F_BARM,#RGDLK);
	F_ARM←F_BARM;

		! updates the arm position;
	READARM(F_BARM);

	$ALLOW←$ALLOW-1;
	$SCLST←$VTLST←$RTLST←$FRLST←$TRLST←NULL;
	IFC #DISPL THENC UPDATE;ENDC
	END;

INTERNAL PROCEDURE DELETEPROC;
	BEGIN
	STRING VAR;
	$HELP←1;
	GTOKEN(FALSE);
	IF FINAL
	   THEN BEGIN				! deletes all the variables;
		STRING ANSWER;
		PRINT("are you sure? ");
		ANSWER←INCHRW;
		PRINT(CRLF);ESC_P;
		IF ANSWER="Y" OR ANSWER="y"
		   THEN	RESET
		   ELSE ABORT1($SEMSG[13]);
		END
	   ELSE BEGIN
		STOKEN←TRUE;
		$ALLOW←$ALLOW+1;
		DO BEGIN "A"
			VAR←IDF_READ;
			KILLVAR(TOKEN);
			GTOKEN(FALSE);
			IF TOKEN≠"," AND NOT FINAL
			   THEN BEGIN
			   PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
		           ERROR($SYNMSG[1],$SYNMSG[25] );
		     	   END;
		   END "A"
		UNTIL FINAL;
		$ALLOW←$ALLOW-1;
		IFC #DISPL THENC UPDATE;ENDC
		END;
	END;

END;